
512 constant filename-max

: pkg-root s" ./" ;

char / constant dirsep

\ Add C-ADDR2 U2 to start of buffer C-ADDR U and return remaining space.
: prefix-chars ( c-addr u  c-addr2 u2 -- c-addr' u' )
	2over swap >r  over u< abort" buffer overflow"
	2dup r> swap chars move  nip /string ;
: prefix-char ( c-addr u char -- c-addr' u' )
	>r 2dup 0= abort" buffer overflow"
	r> swap c! 1 /string ;

create src-filename-buf filename-max chars allot
: pkg-src-filename ( c-addr u -- c-addr' u' )
	2>r src-filename-buf filename-max 2dup
		pkg-root prefix-chars
		s" src" prefix-chars dirsep prefix-char
		2r> prefix-chars
	nip - ;

: parse-line ( "...<cr>" -- c-addr u )
	source >in @  over >in !  /string ;

: src-included ( c-addr u -- )  pkg-src-filename included ;
: include-src ( "filename<cr>" -- )  parse-line src-included ;

1 chars 1 = [if]
: char/ ; immediate
[else]
: char/ 1 chars / ;
[then]
here 10 c,  here over - char/  2constant newline
\ provide vectored output through a deferred `type`.

' type  defer type  is type

create emit-buf 1 chars allot
: emit ( char -- )  emit-buf  tuck c!  1 type ;
: .( ( "ccc<paren>" -- )  [char] ) parse type ; immediate
: ." ( "ccc<quote>" -- )
	[char] " parse postpone sliteral postpone type ; immediate
: space ( -- )  bl emit ;
: spaces ( n -- )  0 max  0 ?do space loop ;
: cr ( -- )  newline type ;
: (ud.) ( ud -- )  <# #s #> type ;
: (d.) ( d -- )
	2dup d0< if dnegate [char] - emit then (ud.) ;
: ud. ( ud -- )  (ud.) space ;
: d. ( d -- )  (d.) space ;
: . ( n -- )  s>d d. ;
: u. ( u -- )  0 ud. ;

: ud.r ( ud n -- )
	0 max >r  <# #s #> tuck type
	r> swap - 0 max spaces ;
: d.r ( d n -- )
	>r 2dup d0< if
		dnegate  [char] - emit  r> 1- >r
	then r> ud.r ;
: .r ( n n -- )  >r s>d r> d.r ;
: u.r ( u n -- )  0 swap ud.r ;

( haven't redefined )
\ .S          ( debugging, leave out? )
\ F. FE. FS.  ( use Ed's implementations? )
\ PAGE EMIT?  ( rare? and system-specific, leave out? )

variable outfile
: type>outfile ( c-addr u -- )  outfile @ write-file throw ;
: outfile-execute ( xt fileid -- )
	outfile  dup @ >r !
		['] type>outfile ['] type  dup defer@ >r defer!
			catch
		r> ['] type defer!
	r> outfile !   throw ;
: 2tuck ( xd1 xd2 -- xd2 xd1 xd2 )  2swap 2over ;
\ cell-counted strings

: lcount ( a-addr -- c-addr u )  dup cell+ swap @ ;
: lplace ( c-addr u a-addr -- )
	2dup !  cell+ swap chars move ;

\ prepend C-ADDR2 U2 to C-ADDR U and return the combined string
: prepend ( c-addr u c-addr2 u2 -- c-addr' u' )
	dup >r  2swap r@ + swap r> chars - swap
	over swap 2>r  swap chars move  2r> ;
\ A path begins with a buffer length and a length used.
\ Path data follows as a series of cell-counted strings.

: path-size ( addr.path -- u )  @ ;
: path-used ( addr.path -- addr )  cell+ ;
: path-max  ( addr.path -- addr )  [ 2 cells ] literal + ;
: path-data ( addr.path -- addr )  [ 3 cells ] literal + ;
: path-free ( addr.path -- u )  dup path-size swap path-used @ - ;
: max-dir-len ( addr.path -- u )  path-max @ ;

: new-path ( u -- addr )
	align here swap chars
		2dup path-data dup allot erase
	over !  0 over path-used ! ;

: insert-space ( u addr.path -- )
	swap chars cell+ aligned swap
	2dup path-free u> abort" buffer overflow"
	2dup 2>r  path-data 2dup + rot move  2r> path-used +! ;
: prepend-dir ( c-addr u addr.path -- )
	2dup 2>r  2dup insert-space path-data lplace
	2r> path-max tuck @ umax swap ! ;

: directories ( addr.path -- addr u )
	dup path-data swap path-used @ ;
: directory ( addr u -- c-addr u' )  drop lcount ;
: next-directory ( addr u -- addr' u' )
	over @ aligned cell+  tuck - >r + r> ;

: 4>r ( xd1 xd2 -- )  ( R: -- xd1 xd2 )
	postpone 2swap postpone 2>r postpone 2>r ; immediate
: 4r@ ( -- xd1 xd2 )  ( R: xd1 xd2 -- xd1 xd2 )
	postpone 2r> postpone 2r@ postpone 2swap
	postpone 2dup postpone 2>r ; immediate
-38 constant no-such-file  \ exception number
variable use-file-xt ( ... c-addr u -- n.exception | ... 0 )
: use-file use-file-xt @ execute ;
\ assumes there is space before c-addr u to prepend directories
: find-in-path ( c-addr u addr.path xt -- n.exception | ... 0 )
	use-file-xt dup @ >r !  directories 4>r
	no-such-file begin r@ while drop
		4r@ directory prepend use-file dup while
	2r> next-directory 2>r repeat then
	2r> 2drop 2r> 2drop  r> use-file-xt ! ;

: pkg-extension ( -- c-addr u )  s" .fs" ;

s" MAX-CHAR" environment? 0= [if]
	0 invert pad tuck ! c@
[then] constant MAX-CHAR
variable first-char
variable prev-char   \ true (all bits set) if no prev char
variable word-break  \ insert a hyphen here if following chars
\ counts of open brackets
variable open-parens
variable open-brackets
variable open-braces
: new-word ( -- )
	first-char on  prev-char on  word-break off
	open-parens off  open-brackets off  open-braces off ;

variable last-char  \ set every char in translate-char
: word-end? ( c-addr u -- flag )  \ assumes u is at least 1
	1 = if drop true else char+ c@ bl = then ;

: hyphen? ( -- flag )
	word-break dup @ swap off  first-char @ 0= and ;
: add-string ( c-addr u c-addr2 u2 -- c-addr' u' )
	hyphen? if 2>r s" -" prefix-chars 2r> then prefix-chars ;
variable ch
: add-char ( c-addr u char -- c-addr' u' )
	ch c! ch 1 add-string ;
: spelled ( c-addr u char c-addr2 u2 -- c-addr' u' )
	rot drop  word-break on  add-string  word-break on ;

create xts MAX-CHAR 1 + cells allot
	\ xts are ( c-addr u char -- c-addr' u' )
	: xt ( char -- addr )  cells xts + ;
	: actions ( xt char1 char2 -- )
		1 + swap ?do dup i xt ! loop drop ;
	:noname drop  word-break on ;  0 MAX-CHAR actions
: translate-char ( c-addr u char -- c-addr' u' )
	first-char @ >r
	prev-char @ >r dup >r
		dup xt @ execute
	r>  r> prev-char @ = if prev-char ! else drop then
	r> first-char @ = if first-char off then ;
: phrase>path ( c-addr u c-addr2 u2 -- c-addr2 u2' )
	new-word 2swap  2over 2>r begin dup while
		2dup word-end? last-char !  over c@
		2r> rot translate-char 2>r
	1 /string repeat 2drop  2r> nip - ;

\ blanks become directory separators
:noname drop  dirsep prefix-char  new-word ; bl xt !

\ these chars are valid anywhere
' add-char char a char z actions
' add-char char A char Z actions
' add-char char 0 char 9 actions
' add-char char _ xt !

\ some characters are context-sensitive

\ '-' is "dash" or "minus" or possibly unchanged
:noname
	last-char @ if s" minus" spelled else
	first-char @ if s" dash" spelled else
	add-char then then ;  char - xt !

\ '>' is "to" or "from" or "greater"
: after-r? ( -- flag )
	prev-char @ dup [char] r = swap [char] R = or ;
:noname
	last-char @ if
		after-r? if s" from" else s" greater" then
	else s" to" then spelled
; char > xt !
:noname
	prev-char @ [char] > = if
		\ change "-to" to "-greater"
		>r -2 /string s" greater" prefix-chars r>
	then s" equals" spelled
; char = xt !

\ closing brackets are ignored unless unmatched.
:noname s" paren" spelled    1 open-parens +! ;    char ( xt !
:noname s" bracket" spelled  1 open-brackets +! ;  char [ xt !
:noname s" brace" spelled    1 open-braces +! ;    char { xt !
:noname open-parens @ if drop  -1 open-parens +!
	else s" rparen" spelled then ;   char ) xt !
:noname open-brackets @ if drop  -1 open-brackets +!
	else s" rbracket" spelled then ; char ] xt ! 
:noname open-braces @ if drop  -1 open-braces +!
	else s" rbrace" spelled then ;   char } xt !

\ most punctuation is always spelled out
:noname s" store" spelled ;     char ! xt !
:noname s" quote" spelled ;     char " xt !
:noname s" number" spelled ;    char # xt !
:noname s" dollar" spelled ;    char $ xt !
:noname s" percent" spelled ;   char % xt !
:noname s" and" spelled ;       char & xt !
:noname s" tick" spelled ;      char ' xt !
:noname s" star" spelled ;      char * xt !
:noname s" plus" spelled ;      char + xt !
:noname s" comma" spelled ;     char , xt !
:noname s" dot" spelled ;       char . xt !
:noname s" slash" spelled ;     char / xt !
:noname s" colon" spelled ;     char : xt !
:noname s" semicolon" spelled ; char ; xt !
:noname s" less" spelled ;      char < xt !
:noname s" question" spelled ;  char ? xt !
:noname s" fetch" spelled ;     char @ xt !
:noname s" backslash" spelled ; char \ xt !
:noname s" caret" spelled ;     char ^ xt !
:noname s" backtick" spelled ;  char ` xt !
:noname s" bar" spelled ;       char | xt !
:noname s" tilde" spelled ;     char ~ xt !

: add-pkg-file ( c-addr u c-addr2 u2 -- c-addr2' u2' )
	2tuck phrase>path nip /string
	pkg-extension prefix-chars ;

\ insert `new` after `this`.
: link-after ( new this -- )  2dup @ swap !  ! ;

\ remove the item after `this`.
: unlink-next ( this -- )  dup @ @ swap ! ;
\ Track which names are currently available.

\ This is a linked list of cell-counted strings.

variable pkgs-available  0 pkgs-available !  \ head of linked list.

: supplied ( c-addr u -- )
	align here  over chars 2 cells + allot
	0 over !  dup >r cell+ lplace  r> pkgs-available link-after ;
: supply ( "...<cr>" -- )  parse-line supplied ;

: supplied? ( c-addr u -- flag )
	pkgs-available begin @ dup while
		3dup cell+ lcount str= until
	then 0<> nip nip ;

create pkg-path 4 1024 * new-path  0 0 rot prepend-dir
create prefer-buf filename-max chars allot
: add-bl ( c-addr u -- c-addr' u' )
	2>r prefer-buf filename-max 2dup
		2r> prefix-chars bl prefix-char
	nip - ;
: preferred ( c-addr u -- )
	dup if add-bl then pkg-path prepend-dir ;
: prefer ( "...<cr>" -- )  parse-line preferred ;

create src-line-buf filename-max 2 + chars allot
: type-file ( c-addr u -- )
	pkg-src-filename r/o open-file abort" no such package source file"
	begin
		src-line-buf 2dup filename-max rot read-line
		abort" failed to read source line" while
			type cr
	repeat 2drop close-file abort" can't close file" ;


variable pkg-mode
: interpret-pkgs ( -- )  0 pkg-mode ! ;
: compile-pkgs ( -- )  1 pkg-mode ! ;
: compile-static-pkgs ( -- )  2 pkg-mode ! ;
: supplied-by ( -- )
	pkg-mode @ if
		begin
			source >in @ /string type cr
		refill 0= until
	then ;
: supplied-by-file ( "filename<cr>" -- )
	parse-line
	pkg-mode @ 0= if src-included else
	pkg-mode @ 1 = if ." include-src " type cr
	else type-file then then ;

create pkg-filename-buf filename-max chars allot
: pkg-filename ( c-addr u -- c-addr' u' )
	pkg-filename-buf filename-max  2tuck
		pkg-root prefix-chars
		s" pkg" prefix-chars dirsep prefix-char
		add-pkg-file
	nip - ;
: load-package? ( c-addr u -- n.exception | 0 )
	2dup supplied? if 2drop 0 else
		2dup supplied  pkg-filename ['] included
		catch dup if nip nip then
	then ;
create pkg-name-buf filename-max chars allot
: buffer-pkg-name ( c-addr u -- c-addr' u )
	dup pkg-path max-dir-len +
	filename-max u> abort" buffer overflow"
	filename-max over -  chars pkg-name-buf + swap
	2dup 2>r chars move 2r> ;
: demanded ( c-addr u -- )
	buffer-pkg-name pkg-path ['] load-package?
	find-in-path throw ;
: demand ( "...<cr>" -- )  parse-line demanded ;

: include-supply ( c-addr u -- )
	pkg-filename-buf filename-max 2tuck
		pkg-root prefix-chars
		s" supply" prefix-chars dirsep prefix-char
		2swap prefix-chars
	nip - included ;
: demanded>file ( c-addr.pkg u.pkg  c-addr.file u.file -- )
	w/o create-file throw  dup >r
		['] demanded swap outfile-execute
	r> close-file throw ;
: make-load-file ( c-addr.pkg u.pkg c-addr.file u.file -- )
	pkg-mode @ >r compile-static-pkgs
		s" marker <<demand>>" evaluate
			2dup include-supply  demanded>file
		s" <<demand>>" evaluate
		0 pkgs-available !
		0 pkg-path path-used !  0 0 pkg-path prepend-dir
	r> pkg-mode ! ;
: make-load-files ( c-addr.pkg u.pkg -- )
	2dup s" gforth.fs" make-load-file
	2dup s" iforth.fs" make-load-file
	2dup s" pforth.fs" make-load-file
	2dup s" swiftforth.fs" make-load-file
	2dup s" vfxforth.fs" make-load-file
	s" win32forth.fs" make-load-file ;
